home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / menu_u.zip / MENUMK.PAS < prev    next >
Pascal/Delphi Source File  |  1993-04-11  |  11KB  |  352 lines
  1. Unit MenuMK;
  2.  
  3. { Unit COPYRIGHT 1991 MARK KLAAMAS              }
  4. { RELEASED TO PUBLIC DOMAIN ON 20 DECEMBER 1991 }
  5.  
  6. (**) Interface (**)
  7.  
  8. uses Crt;
  9.  
  10. const
  11.   MaxMsgLen  = 40;
  12. type
  13.   MessageString = String[MaxMsgLen];
  14.   EntryPointer  = ^EntryType;
  15.   EntryType     = Object
  16.     prev, next  : EntryPointer;
  17.     Xcor, Ycor,
  18.     ChoiceNo    : Integer;
  19.     Message     : MessageString;
  20.  
  21.     Constructor Init( iPr, iNx    : EntryPointer;
  22.                      iX, iY, iC  : Integer;
  23.                      iM          : MessageString );
  24.  
  25.     Procedure Draw( Selected     : Boolean );
  26.  
  27.     Function GetChoice           : Integer;
  28.   end; { Object EntryType }
  29.  
  30.   BBMenu = Object
  31.     Xcor, Ycor, Wid, Choices     : Integer;
  32.     FirstEntry, Curentry         : EntryPointer;
  33.     MenuTitle                    : String;
  34.     MenuStyle                    : Byte;
  35.     SideExit                     : Boolean;
  36.  
  37.     Constructor Init(iX, iY, iW : Integer;
  38.                      MTitle     : String;
  39.                      MenuC, HiC,
  40.                      Style      : byte;
  41.                      SExit      : Boolean);
  42.     Destructor Done;
  43.     Procedure AddPrompt( iM      : MessageString);
  44.     Procedure Draw;
  45.     Function GetChoice           : Integer;
  46.   end; { Object BBMenu }
  47.  
  48. Procedure MakeWindow( ULx, ULy, LRx, LRy, Color, CharType : Byte;
  49.                       Banner : String;
  50.                       Shadow : Boolean );
  51.  
  52. procedure WritePos( InStr : String; XCor, YCor : Byte);
  53.  
  54. procedure SetVideoAddress;
  55.  
  56. (**) Implementation (**)
  57.  
  58. { Routine to get screen Type }
  59. var
  60.   VidAddr : word;            (* This variable will indicate the      *)
  61.                              (* memory address of the video-screen   *)
  62.                              (* array that we want to write our      *)
  63.                              (* string to.                           *)
  64.  
  65.                              (* Initialize the VidAddr variable.     *)
  66.  
  67.   procedure SetVideoAddress;
  68.   begin
  69.     if ((Mem[$0000:$0410] and $30) <> $30) then
  70.       VidAddr := $B800     (* Color video mode.                    *)
  71.     else
  72.       VidAddr := $B000;    (* Monochrome video mode.               *)
  73.   end;
  74.  
  75. procedure WritePos( InStr : String; XCor, YCor : Byte);
  76. begin
  77.   GotoXY(XCor, YCor);
  78.   Write(InStr);
  79. end; { procedure WritePos }
  80.  
  81.  
  82. { Window Routine used in unit. }
  83.  
  84. Procedure MakeWindow( ULx, ULy, LRx, LRy, Color, CharType : Byte;
  85.                       Banner : String;
  86.                       Shadow : Boolean );
  87.  
  88. var
  89.    VidOffset : Word;                       { Define memory area }
  90.    Len       : Byte;                       { Define Length of block }
  91.    Width     : Byte;                       { Define Width of block }
  92.    BorderChar: string[80];                 { Define var for border }
  93.    Chars     : String[8];                  { Define the corners }
  94.    Center    : Byte;                       { Define the center of box L-R }
  95.  
  96. begin
  97.      Window( ULx, ULy, LRx, LRy );         { Define Window bounds. }
  98.      TextAttr := Color;
  99.      ClrScr;                               { Fill Block With text color }
  100.  
  101.      Window( 1, 1, 80, 25 );
  102.  
  103.      { Make the border for the window }
  104.      case CharType of
  105.           0 : Chars := '║═╔╗╚╝╠╣';
  106.           1 : Chars := '║─╓╖╙╜╟╢';
  107.           2 : Chars := '│═╒╕╘╛╞╡';
  108.           3 : Chars := '│─┌┐└┘├┤';
  109.           4 : Chars := '        ';
  110.      end;
  111.  
  112.      { TOP }
  113.      FillChar( BorderChar, LRx - ULx, Chars[2] );    { Fill In Middle }
  114.      BorderChar[0] := char(LRx - ULx);
  115.      Insert( Chars[3], BorderChar, 1 );              { Left Corner }
  116.      BorderChar[LRx - ULx +1] := Chars[4];           { Right Corner }
  117.      WritePos( BorderChar, ULx, ULy );               { Put BorderChar on SCR }
  118.  
  119.      { Middle }
  120.      BorderChar := Chars[1];
  121.      for Len := ULy + 1 to LRy - 1 do
  122.      begin
  123.          For Width := 1 to 2 do
  124.          begin
  125.            if Width = 1 then
  126.              WritePos(BorderChar, ULx, Len)
  127.            else
  128.              WritePos(BorderChar, LRx, Len);
  129.          end;
  130.      end;
  131.  
  132.      { Bottom }
  133.      FillChar( BorderChar, LRx - ULx, Chars[2] );          { Fill In Middle }
  134.      BorderChar[0] := char(LRx - ULx);
  135.      Insert( Chars[5], BorderChar, 1 );                       { Left Corner }
  136.      BorderChar[LRx - ULx +1] := Chars[6];                   { Right Corner }
  137.      WritePos( BorderChar, ULx, LRy );  {             Put BorderChar on SCR }
  138.  
  139.      if Shadow = True then                   { Okay Shadow wanted .. }
  140.      begin
  141.       if LRx < 80 - 2 then              { Set condition for shadowing }
  142.       if LRy < 25 - 1 then                 { Make sure won't scroll }
  143.       begin
  144.         Width := 0;                             { Set var for shadow }
  145.         { Do the Shadow on the right side }
  146.         For Len := 0 to (LRy - ULy - 1) do
  147.         begin
  148.            VidOffset := (80 * ((ULy + Len) * 2))  { Set Video Offset }
  149.                      + ((LRx) * 2) + 1;
  150.            While Width <= 2 do
  151.            begin
  152.              Mem[VidAddr : VidOffset + Width] := $08;   { Actually write }
  153.              Inc( Width, 2 );                           {  on screen     }
  154.            end;
  155.            Width := 0;                                  { Reset the Width var }
  156.         end;
  157.  
  158.         { Do shadow on bottom }
  159.         Width := 0;
  160.         VidOffset := (80 * ((LRy) * 2))  { Set Video Offset }
  161.                      + ((ULx + Width + 1) * 2) + 1;
  162.         While Width < (LRx - Ulx + 1 ) * 2 do
  163.         begin
  164.            Mem[VidAddr : VidOffset + Width] := $08;  { Actual write to screen }
  165.            Inc( Width, 2 );
  166.         end;
  167.       end;{ of Condition IF statement }
  168.      end; { of Shadowing section }
  169.  
  170.      if Banner <> '' then
  171.      begin
  172.         { Display Banner }
  173.         Center := ((LRx - ULx) div 2) - ((Length(Banner) div 2));
  174.         WritePos( Banner, ULx + Center, ULy + 1 );
  175.  
  176.         { Make line for botom of banner }
  177.         FillChar( BorderChar, LRx - ULx - 2, Chars[2] );
  178.         BorderChar[0] := Char( LRx - ULx - 1 );
  179.         Insert( Chars[7], BorderChar, 1 );
  180.         BorderChar := BorderChar + Chars[8];
  181.         WritePos( BorderChar, ULx, ULy + 2 );
  182.      end;
  183.  
  184. end; { procedure MakeWindow }
  185.  
  186. var
  187.   MenuColour, HiLight          : Byte;
  188.  
  189.   constructor BBMenu.Init(iX, iY, iW :  Integer;
  190.                           MTitle     : string;
  191.                           MenuC, HiC,
  192.                           Style      : byte;
  193.                           SExit      : Boolean);
  194.   begin
  195.     XCor := iX;
  196.     YCor := iY;
  197.     Wid  := iW;
  198.     MenuTitle  := MTitle;                    { Setup Title of Menu     }
  199.     MenuStyle  := Style;                     { Setup border type.      }
  200.     MenuColour := MenuC;                     { Setup background colour }
  201.     HiLight    := HiC;                       { Setup bounce bar colour }
  202.     SideExit   := SExit;                     { Setup flag for sideexit }
  203.     if Wid > MaxMsgLen then
  204.        Wid := MaxMsgLen;
  205.     if Xcor + Wid > 80 then
  206.        Wid := 80 - XCor;
  207.     FirstEntry := NIL;
  208.     Choices := 0;
  209.   end; { constructor BBMenu.Init }
  210.  
  211.   destructor BBMenu.Done;
  212.   begin
  213.     if FirstEntry <> NIL then
  214.     begin
  215.       FirstEntry^.Prev^.Next := Nil;
  216.       repeat
  217.         CurEntry := FirstEntry;
  218.         FirstEntry := FirstEntry^.Next;
  219.         Dispose(CurEntry);
  220.       until FirstEntry = NIL;
  221.     end;
  222.   end; { destructor BBMenu.Done }
  223.  
  224.   procedure BBmenu.AddPrompt(iM : MessageString);
  225.   var
  226.     EP : EntryPointer;
  227.   begin
  228.     Inc(Choices);
  229.     { pad with spaces }
  230.     FillChar(iM[length(iM) + 1], Wid - length(iM), #32);
  231.     iM[0] := char(Wid);
  232.     If FirstEntry = NIL then
  233.     begin
  234.       FirstEntry := New(EntryPointer, Init(NIL, NIL, XCor,
  235.                          YCor + Choices - 1, Choices, iM));
  236.       FirstEntry^.Next := FirstEntry;
  237.       FirstEntry^.Prev := FirstEntry;
  238.     end
  239.     else
  240.     begin
  241.       EP := New(EntryPointer, Init(FirstEntry^.Prev, FirstEntry,
  242.                 XCor, YCor + Choices - 1, Choices, iM));
  243.       FirstEntry^.Prev^.Next := EP;
  244.       FirstEntry^.Prev := EP;
  245.     end;
  246.   end; { procedure BBMenu.AddPrompt }
  247.  
  248.   procedure BBMenu.Draw;
  249.   var ro, co : Byte;
  250.   begin
  251.     if MenuTitle = '' then
  252.       MakeWindow(XCor-1, YCor-1, XCor + Wid, YCor + Choices,
  253.                MenuColour, MenuStyle, '', True)
  254.     else
  255.       MakeWindow(XCor-1, YCor-3, XCor + Wid, YCor + Choices,
  256.                MenuColour, MenuStyle, MenuTitle, True);
  257.  
  258.     CurEntry := FirstEntry;
  259.     repeat
  260.       CurEntry^.Draw(False);
  261.       CurEntry := CurEntry^.Next;
  262.     until CurEntry = FirstEntry;
  263.   end; { procedure BBMenu.Draw }
  264.  
  265.   const
  266.     KEnter = $000D;   KEsc   = $001B;
  267.     KHome  = $4700;   KEnd   = $4F00;
  268.     KLeft  = $4B00;   KRight = $4D00;
  269.     KDown  = $5000;   KUp    = $4800;
  270.  
  271.   function BBMenu.GetChoice : Integer;
  272.   var
  273.     SaveX, SaveY : Integer;
  274.     Finished     : Boolean;
  275.     InChar       : Char;
  276.     InWord       : Word;
  277.   begin
  278.     SaveX := WhereX;
  279.     SaveY := WhereY;
  280.     TextAttr := MenuColour;
  281.     Draw;
  282.     Finished := False;
  283.     REPEAT
  284.       CurEntry^.Draw(True);                  { Write HI-Lighted option }
  285.       InChar := ReadKey;
  286.       If (InChar = #0) and KeyPressed then
  287.       begin
  288.         InChar := Readkey;
  289.         InWord := Word(InChar) SHL 8;
  290.       end
  291.       else
  292.         InWord := Ord(InChar);
  293.       CurEntry^.Draw(False);
  294.  
  295.       case InWord of
  296.         kUp    : CurEntry := CurEntry^.Prev;
  297.         kDown  : CurEntry := CurEntry^.Next;
  298.         kHome  : CurEntry := FirstEntry;
  299.         kEnd   : CurEntry := FirstEntry^.Prev;
  300.         kLeft  : if SideExit then
  301.                  begin
  302.                    Finished := True;         { Left selected  }
  303.                    GetChoice := -1;
  304.                  end;
  305.         kRight : If SideExit then
  306.                  begin
  307.                    Finished := True;         { Right Selected }
  308.                    GetChoice := -2;
  309.                  end;
  310.         kEsc   : begin
  311.                    Finished := True;
  312.                    GetChoice := 0;
  313.                  end;
  314.         kEnter : begin
  315.                     Finished := True;
  316.                     GetChoice := CurEntry^.GetChoice;
  317.                  end;
  318.       end;
  319.     until Finished;
  320.   GotoXY(SaveX, SaveY);
  321. end;
  322.  
  323. constructor EntryType.Init(iPr, iNx   : EntryPointer;
  324.                           iX, iY, iC : Integer;
  325.                           iM         : MessageString);
  326. begin
  327.   Prev     := iPr;
  328.   Next     := iNx;
  329.   Xcor     := iX;
  330.   YCor     := iY;
  331.   ChoiceNo := iC;
  332.   Message  := iM;
  333. end;
  334.  
  335. procedure EntryType.Draw(Selected : Boolean);
  336. begin
  337.   If Selected then
  338.      TextAttr := HiLight
  339.   else
  340.      TextAttr := MenuColour;
  341.   WritePos(Message, Xcor, YCor);
  342. end;
  343.  
  344. function EntryType.GetChoice : Integer;
  345. begin
  346.   GetChoice := ChoiceNo;
  347. end;
  348.  
  349. begin
  350.   SetVideoAddress;
  351. end.
  352.